The shape of tides
The goal of this project is to analyse tide times in Galway and try
to extract some information on the periodicity of tide times. We’ll use
methods from an area of maths called topology.
We first load the R-TDA package
#install.packages('TDA')
library(TDA)
We will now read tide times from 15/03-29/03.
tides <- read.csv(file="/Users/jamesmcgloin/Documents/CodingProjects/The-Shape-of-Tides/galwaytides.csv", nrows=3411, header=FALSE)
height <- tides[,8]
We now create an index to sample 200 values from our tide times
index = seq(1,200)
We create three vectors the first containing tide times at time \(t_0\) the second containing values at \(t_0 + 2hrs\) and the third at \(t+4hrs\) .
h <- c() # heights
h2 <- c() # heights at t + 2h
h4 <- c() # heights at t + 4h
for (i in index) {
h <- append(h, height[i])
h2 <- append(h2, height[i+20])
h4 <- append(h4, height[i+40])
}
We know create a data frame consisting of 3 columns corresponding to
\(h\), \(h_2\) and \(h_4\) and create a \(3D\) plot of the data
#install.packages("plotly")
library(plotly)
Loading required package: ggplot2
Registered S3 method overwritten by 'data.table':
method from
print.data.table
Registered S3 method overwritten by 'htmlwidgets':
method from
print.htmlwidget tools:rstudio
Attaching package: ‘plotly’
The following object is masked from ‘package:ggplot2’:
last_plot
The following object is masked from ‘package:stats’:
filter
The following object is masked from ‘package:graphics’:
layout
data = data.frame(h,h2,h4)
fig <-plot_ly(data = data, x=~h, y=~h2, z=~h4, type="scatter3d", mode="markers")%>%
layout(title = 'Tide Heights', plot_bgcolor = "#e5ecf6")
fig
We can see clearly from this plot that there is some periodic motion
going on in our data. We’ll now look at a way of extracting this info
using topological data analysis.
We create our Vietoris Rips complex using the ripsDiag() function.
I’l set max dimension as 1 as I won’t be considering persistence in the
second homology group or above. In fact this would be ineffecient to
calculate and, at least in \(H_2\), we
don’t detect any interesting features (I didn’t bother computing for
higher homology groups but I suspect a similar result ).
I’ll set max scale to 5 as this turns out to be an appropriate scale
for our data and I’ll use the standard Eulidean distance as our
metric.
maxdimension <- 1
maxscale <- 5
Diag <- ripsDiag(X = data.frame(h,h2,h4),
maxdimension,
maxscale,
dist = "euclidean",
library = "GUDHI",
printProgress = FALSE)
Now we plot a persistence diagram of our data
#print(Diag[["diagram"]])
plot(Diag[["diagram"]], barcode=FALSE, main = "Persistence Diagram")
legend(3.5, 5, legend=c("Holes", "Components"),
col=c("red", "black"), cex=0.8, pch = c(17,19))

The red triangles in our diagrams correspond to birth/death times of
“holes” and the black dots correspond to birth/death times of connected
components
And finally we output a barcode of persisting features in \(H_0\) and \(H_1\).
plot(Diag[["diagram"]], barcode=TRUE, main = "Barcode")
legend("topright", legend=c("Holes", "Components"),
col=c("red", "black"), cex=0.8, lty= 1:1)

Conclusion
We see from both the persistence diagram and the bar code that there
is persistence in the second homology group, i.e. there is a
1-dimensional hole in our data.
This is exactly what we should expect with the motion of the tide!
Really the hole that we are picking up on is that of the moon orbiting
the earth which in my opinion is pretty neat.
LS0tCnRpdGxlOiAiVGhlIFNoYXBlIG9mIFRpZGVzIgpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sKLS0tCgojIFRoZSBzaGFwZSBvZiB0aWRlcwoKVGhlIGdvYWwgb2YgdGhpcyBwcm9qZWN0IGlzIHRvIGFuYWx5c2UgdGlkZSB0aW1lcyBpbiBHYWx3YXkgYW5kIHRyeSB0byBleHRyYWN0IHNvbWUgaW5mb3JtYXRpb24gb24gdGhlIHBlcmlvZGljaXR5IG9mIHRpZGUgdGltZXMuIFdlJ2xsIHVzZSBtZXRob2RzIGZyb20gYW4gYXJlYSBvZiBtYXRocyBjYWxsZWQgdG9wb2xvZ3kuCgpXZSBmaXJzdCBsb2FkIHRoZSBSLVREQSBwYWNrYWdlCgpgYGB7cn0KI2luc3RhbGwucGFja2FnZXMoJ1REQScpCmxpYnJhcnkoVERBKQpgYGAKCldlIHdpbGwgbm93IHJlYWQgdGlkZSB0aW1lcyBmcm9tIDE1LzAzLTI5LzAzLgoKYGBge3J9CnRpZGVzIDwtIHJlYWQuY3N2KGZpbGU9Ii9Vc2Vycy9qYW1lc21jZ2xvaW4vRG9jdW1lbnRzL0NvZGluZ1Byb2plY3RzL1RoZS1TaGFwZS1vZi1UaWRlcy9nYWx3YXl0aWRlcy5jc3YiLCBucm93cz0zNDExLCBoZWFkZXI9RkFMU0UpCmhlaWdodCA8LSB0aWRlc1ssOF0KYGBgCgpXZSBub3cgY3JlYXRlIGFuIGluZGV4IHRvIHNhbXBsZSAyMDAgdmFsdWVzIGZyb20gb3VyIHRpZGUgdGltZXMKCmBgYHtyfQppbmRleCA9IHNlcSgxLDIwMCkKYGBgCgpXZSBjcmVhdGUgdGhyZWUgdmVjdG9ycyB0aGUgZmlyc3QgY29udGFpbmluZyB0aWRlIHRpbWVzIGF0IHRpbWUgJHRfMCQgdGhlIHNlY29uZCBjb250YWluaW5nIHZhbHVlcyBhdCAkdF8wICsgMmhycyQgYW5kIHRoZSB0aGlyZCBhdCAkdCs0aHJzJCAuCgpgYGB7cn0KaCA8LSBjKCkgICMgaGVpZ2h0cwpoMiA8LSBjKCkgIyBoZWlnaHRzIGF0IHQgKyAyaApoNCA8LSBjKCkgIyBoZWlnaHRzIGF0IHQgKyA0aApmb3IgKGkgaW4gaW5kZXgpIHsKICBoICA8LSBhcHBlbmQoaCwgIGhlaWdodFtpXSkKICBoMiA8LSBhcHBlbmQoaDIsIGhlaWdodFtpKzIwXSkKICBoNCA8LSBhcHBlbmQoaDQsIGhlaWdodFtpKzQwXSkKfQpgYGAKCldlIGtub3cgY3JlYXRlIGEgZGF0YSBmcmFtZSBjb25zaXN0aW5nIG9mIDMgY29sdW1ucyBjb3JyZXNwb25kaW5nIHRvICRoJCwgJGhfMiQgYW5kICRoXzQkIGFuZCBjcmVhdGUgYSAkM0QkIHBsb3Qgb2YgdGhlIGRhdGEKCmBgYHtyfQojaW5zdGFsbC5wYWNrYWdlcygicGxvdGx5IikKbGlicmFyeShwbG90bHkpCmBgYAoKYGBge3J9CmRhdGEgPSBkYXRhLmZyYW1lKGgsaDIsaDQpCmZpZyA8LXBsb3RfbHkoZGF0YSA9IGRhdGEsIHg9fmgsIHk9fmgyLCB6PX5oNCwgdHlwZT0ic2NhdHRlcjNkIiwgbW9kZT0ibWFya2VycyIpJT4lCiAgICAgICAgbGF5b3V0KHRpdGxlID0gJ1RpZGUgSGVpZ2h0cycsIHBsb3RfYmdjb2xvciA9ICIjZTVlY2Y2IikKZmlnCmBgYAoKV2UgY2FuIHNlZSBjbGVhcmx5IGZyb20gdGhpcyBwbG90IHRoYXQgdGhlcmUgaXMgc29tZSBwZXJpb2RpYyBtb3Rpb24gZ29pbmcgb24gaW4gb3VyIGRhdGEuIFdlJ2xsIG5vdyBsb29rIGF0IGEgd2F5IG9mIGV4dHJhY3RpbmcgdGhpcyBpbmZvIHVzaW5nIHRvcG9sb2dpY2FsIGRhdGEgYW5hbHlzaXMuCgpXZSBjcmVhdGUgb3VyIFZpZXRvcmlzIFJpcHMgY29tcGxleCB1c2luZyB0aGUgcmlwc0RpYWcoKSBmdW5jdGlvbi4gSSdsIHNldCBtYXggZGltZW5zaW9uIGFzIDEgYXMgSSB3b24ndCBiZSBjb25zaWRlcmluZyBwZXJzaXN0ZW5jZSBpbiB0aGUgc2Vjb25kIGhvbW9sb2d5IGdyb3VwIG9yIGFib3ZlLiBJbiBmYWN0IHRoaXMgd291bGQgYmUgaW5lZmZlY2llbnQgdG8gY2FsY3VsYXRlIGFuZCwgYXQgbGVhc3QgaW4gJEhfMiQsIHdlIGRvbid0IGRldGVjdCBhbnkgaW50ZXJlc3RpbmcgZmVhdHVyZXMgKEkgZGlkbid0IGJvdGhlciBjb21wdXRpbmcgZm9yIGhpZ2hlciBob21vbG9neSBncm91cHMgYnV0IEkgc3VzcGVjdCBhIHNpbWlsYXIgcmVzdWx0ICkuCgpJJ2xsIHNldCBtYXggc2NhbGUgdG8gNSBhcyB0aGlzIHR1cm5zIG91dCB0byBiZSBhbiBhcHByb3ByaWF0ZSBzY2FsZSBmb3Igb3VyIGRhdGEgYW5kIEknbGwgdXNlIHRoZSBzdGFuZGFyZCBFdWxpZGVhbiBkaXN0YW5jZSBhcyBvdXIgbWV0cmljLgoKYGBge3J9Cm1heGRpbWVuc2lvbiA8LSAxCm1heHNjYWxlIDwtIDUKRGlhZyA8LSByaXBzRGlhZyhYID0gZGF0YS5mcmFtZShoLGgyLGg0KSwKICAgICAgICAgICAgICAgICBtYXhkaW1lbnNpb24sCiAgICAgICAgICAgICAgICAgbWF4c2NhbGUsCiAgICAgICAgICAgICAgICAgZGlzdCA9ICJldWNsaWRlYW4iLAogICAgICAgICAgICAgICAgIGxpYnJhcnkgPSAiR1VESEkiLAogICAgICAgICAgICAgICAgIHByaW50UHJvZ3Jlc3MgPSBGQUxTRSkKYGBgCgpOb3cgd2UgcGxvdCBhIHBlcnNpc3RlbmNlIGRpYWdyYW0gb2Ygb3VyIGRhdGEKCmBgYHtyfQojcHJpbnQoRGlhZ1tbImRpYWdyYW0iXV0pCnBsb3QoRGlhZ1tbImRpYWdyYW0iXV0sIGJhcmNvZGU9RkFMU0UsICBtYWluID0gIlBlcnNpc3RlbmNlIERpYWdyYW0iKQpsZWdlbmQoMy41LCA1LCBsZWdlbmQ9YygiSG9sZXMiLCAiQ29tcG9uZW50cyIpLAogICAgICAgY29sPWMoInJlZCIsICJibGFjayIpLCBjZXg9MC44LCBwY2ggPSBjKDE3LDE5KSkKYGBgCgpUaGUgcmVkIHRyaWFuZ2xlcyBpbiBvdXIgZGlhZ3JhbXMgY29ycmVzcG9uZCB0byBiaXJ0aC9kZWF0aCB0aW1lcyBvZiAiaG9sZXMiIGFuZCB0aGUgYmxhY2sgZG90cyBjb3JyZXNwb25kIHRvIGJpcnRoL2RlYXRoIHRpbWVzIG9mIGNvbm5lY3RlZCBjb21wb25lbnRzCgpBbmQgZmluYWxseSB3ZSBvdXRwdXQgYSBiYXJjb2RlIG9mIHBlcnNpc3RpbmcgZmVhdHVyZXMgaW4gJEhfMCQgYW5kICRIXzEkLgoKYGBge3J9CnBsb3QoRGlhZ1tbImRpYWdyYW0iXV0sIGJhcmNvZGU9VFJVRSwgIG1haW4gPSAiQmFyY29kZSIpCmxlZ2VuZCgidG9wcmlnaHQiLCBsZWdlbmQ9YygiSG9sZXMiLCAiQ29tcG9uZW50cyIpLAogICAgICAgY29sPWMoInJlZCIsICJibGFjayIpLCBjZXg9MC44LCBsdHk9IDE6MSkKYGBgCgojIyBDb25jbHVzaW9uCgpXZSBzZWUgZnJvbSBib3RoIHRoZSBwZXJzaXN0ZW5jZSBkaWFncmFtIGFuZCB0aGUgYmFyIGNvZGUgdGhhdCB0aGVyZSBpcyBwZXJzaXN0ZW5jZSBpbiB0aGUgc2Vjb25kIGhvbW9sb2d5IGdyb3VwLCBpLmUuIHRoZXJlIGlzIGEgMS1kaW1lbnNpb25hbCBob2xlIGluIG91ciBkYXRhLgoKVGhpcyBpcyBleGFjdGx5IHdoYXQgd2Ugc2hvdWxkIGV4cGVjdCB3aXRoIHRoZSBtb3Rpb24gb2YgdGhlIHRpZGUhIFJlYWxseSB0aGUgaG9sZSB0aGF0IHdlIGFyZSBwaWNraW5nIHVwIG9uIGlzIHRoYXQgb2YgdGhlIG1vb24gb3JiaXRpbmcgdGhlIGVhcnRoIHdoaWNoIGluIG15IG9waW5pb24gaXMgcHJldHR5IG5lYXQuCgo=